home *** CD-ROM | disk | FTP | other *** search
/ Megaware 1 / Megaware Volume 1.iso / utils / infoplus / scrprt.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-12-08  |  7.6 KB  |  328 lines
  1. unit scrprt;
  2. {$A-,B-,D-,E-,F-,L-,N-,O-,R-,S-,V-}
  3.  
  4. interface
  5.  
  6. procedure screenprint(pg: byte; pgname, vernum: string);
  7.  
  8. implementation
  9.  
  10. uses
  11.   Dos, Crt, externs;
  12.  
  13. const
  14.   ESC = #27;
  15.  
  16. type
  17.   charset = set of char;
  18.  
  19.  
  20. procedure modeinfo(var vidmode, vidlen, vidpg: byte; var vidwid: word);
  21.   var
  22.     regs: registers;
  23.  
  24.   begin
  25.   with regs do
  26.     begin
  27.     AH:=$0F;
  28.     Intr($10, regs);
  29.     vidmode:=AL;
  30.     vidwid:=AH;
  31.     vidpg:=BH;
  32.     AX:=$1A00;
  33.     Intr($10, regs);
  34.     if AL = $1A then
  35.       vidlen:=Mem[$40:$84] + 1;
  36.     AX:=$1200;
  37.     BL:=$10;
  38.     Intr($10, regs);
  39.     if BL = $10 then
  40.       vidlen:=25
  41.     else
  42.       vidlen:=Mem[$40:$84] + 1;
  43.     end
  44.   end; {modeinfo}
  45.  
  46. procedure box;
  47.   const
  48.     frame: array[1..8] of char = '╔═╗║║╚═╝';
  49.   var
  50.     h, w, x, y: word;
  51.  
  52.   begin
  53.   w:=Lo(WindMax) - Lo(WindMin) + 1;
  54.   h:=Hi(WindMax) - Hi(WindMin) + 1;
  55.   Inc(WindMax, $0101);
  56.   GotoXY(1, 1);
  57.   Write(frame[1]);
  58.   for x:=2 to w - 1 do
  59.     Write(frame[2]);
  60.   GotoXY(w, 1);
  61.   Write(frame[3]);
  62.   for y:=2 to h - 1 do
  63.     begin
  64.     GotoXY(1, y);
  65.     Write(frame[4]);
  66.     GotoXY(w, y);
  67.     Write(frame[5]);
  68.     end;
  69.   GotoXY(1, h);
  70.   Write(frame[6]);
  71.   GotoXY(2, h);
  72.   for x:=2 to w-1 do
  73.     Write(frame[7]);
  74.   GotoXY(w, h);
  75.   Write(frame[8]);
  76.   Dec(WindMax, $0202);
  77.   Inc(WindMin, $0101);
  78.   end;
  79.  
  80. function getkey(cs: charset): char;
  81.   var
  82.     c, x: char;
  83.  
  84.   begin
  85.   repeat
  86.     c:=UpCase(ReadKey);
  87.     if KeyPressed and (c = #0) then
  88.       x:=ReadKey;
  89.   until c in cs;
  90.   if Ord(c) > 31 then
  91.     Writeln(c);
  92.   getkey:=c
  93.   end;
  94.  
  95. function today: string;
  96.   const
  97.     downame: array[0..6] of string[3] = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu',
  98.                                          'Fri', 'Sat');
  99.     monthname: array[1..12] of string[3] = ('Jan', 'Feb', 'Mar', 'Apr', 'May',
  100.                                             'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
  101.                                             'Nov', 'Dec');
  102.   var
  103.     regs: registers;
  104.     dayform, year, month, day, dow: word;
  105.     yearstr, daystr: string[5];
  106.     cinfo: array[0..$21] of byte;
  107.     temp: string;
  108.  
  109.   begin
  110.   GetDate(year, month, day, dow);
  111.   with regs do
  112.     begin
  113.     AH:=$38;
  114.     AL:=0;
  115.     DS:=Seg(cinfo);
  116.     DX:=Ofs(cinfo);
  117.     MsDos(regs);
  118.     dayform:=cinfo[0] + (word(256) * cinfo[1]);
  119.     end;
  120.   Str(day, daystr);
  121.   Str(year, yearstr);
  122.   case dayform of
  123.     0,3..$FFFF: temp:=monthname[month] + ' ' + daystr + ', ' + yearstr;
  124.     1: temp:=daystr + ' ' + monthname[month] + ', ' + yearstr;
  125.     2: temp:=yearstr + ' ' + monthname[month] + ' ' + daystr;
  126.   end;
  127.   today:=downame[dow] + ', ' + temp
  128.   end; {today}
  129.  
  130. function time: string;
  131.   var
  132.     regs: registers;
  133.     hour, min, sec, sec100: word;
  134.     hourstr, minstr, secstr: string[2];
  135.     cinfo: array[0..$21] of byte;
  136.     tform: byte;
  137.     tsep: char;
  138.     temp: string[11];
  139.  
  140.   begin
  141.   GetTime(hour, min, sec, sec100);
  142.   with regs do
  143.     begin
  144.     AH:=$38;
  145.     AL:=0;
  146.     DS:=Seg(cinfo);
  147.     DX:=Ofs(cinfo);
  148.     MsDos(regs);
  149.     tform:=cinfo[$11];
  150.     tsep:=Chr(cinfo[$D]);
  151.     end;
  152.   Str(hour, hourstr);
  153.   if (hour > 12) and (tform and 1 = 0) then
  154.     Str(hour - 12, hourstr);
  155.   if (hour = 0) and (tform and 1 = 0) then
  156.      hourstr:='12';
  157.   Str(min, minstr);
  158.   if Length(minstr) = 1 then
  159.     minstr:='0' + minstr;
  160.   Str(sec, secstr);
  161.   if Length(secstr) = 1 then
  162.     secstr:='0' + secstr;
  163.   temp:=hourstr + tsep + minstr + tsep + secstr;
  164.   if (tform and 1 = 0) then
  165.     if hour > 11 then
  166.       temp:=temp + ' pm'
  167.     else
  168.       temp:=temp + ' am';
  169.   time:=temp
  170.   end; {time}
  171.  
  172.  
  173. procedure screenprint(pg: byte; pgname, vernum: string);
  174.   const
  175.     lochars: array[#0..#$1F] of char = ' abcdefghijklmno' +
  176.                                        'pqrstuvwxyz<+>^v';
  177.  
  178.     hichars: array[#$80..#$FF] of char = 'cueaaaaceeeiiiAA' +
  179.                                   {90h}  'EaAooouuyOUcLYPf' +
  180.                                   {A0h}  'aiounNao?++24i<>' +
  181.                                   {B0h}  '.oO|++++++|+++++' +
  182.                                   {C0h}  '++++-++++++++-++' +
  183.                                   {D0h}  '++++++++++++_||~' +
  184.                                   {E0h}  'aBr#Eout00^o80EU' +
  185.                                   {F0h}  '=+><fj-~oOojn2O ';
  186.     dashes: string[79] = '----------------------------------------' +
  187.                          '---------------------------------------';
  188.  
  189.   var
  190.     scrbuf: array[0..7999] of char;
  191.     vidmode, vidlen, vidpg, oldattr: byte;
  192.     vidwid, vidseg, x, bpl, bps, charcount, first, last: word;
  193.     regs: registers;
  194.     outfile: text;
  195.     filename: PathStr;
  196.     monoscrn: array[0..3999] of char absolute $B000:0;
  197.     colorscrn: array[0..7999] of char absolute $B800:0;
  198.     c: char;
  199.     striphi: boolean;
  200.     extrastr: string;
  201.  
  202.   procedure cleanup;
  203.     begin
  204.     if vidmode = 7 then
  205.       Move(scrbuf, monoscrn, 4000)
  206.     else
  207.       Move(scrbuf, colorscrn, 8000);
  208.     TextAttr:=OldAttr;
  209.     end;
  210.  
  211.   begin
  212.   oldattr:=TextAttr;
  213.   modeinfo(vidmode, vidlen, vidpg, vidwid);
  214.   if vidmode = 7 then
  215.     Move(monoscrn, scrbuf, 4000)
  216.   else
  217.     Move(colorscrn, scrbuf, 8000);
  218.   TextColor(White);
  219.   TextBackground(Blue);
  220.   Window(5, (vidlen div 2) - 5, 75, (vidlen div 2) + 5);
  221.   box;
  222.   TextBackground(LightGray);
  223.   TextColor(Black);
  224.   ClrScr;
  225.   Write('Dump screen to a <F>ile or the <P>rinter.=>');
  226.   c:=getkey([ESC, 'F', 'P']);
  227.   if c = ESC then
  228.     begin
  229.     cleanup;
  230.     Exit
  231.     end;
  232.   if c = 'P' then
  233.     begin
  234.     Assign(outfile, 'PRN');
  235.     ReWrite(outfile)
  236.     end
  237.   else
  238.     begin
  239.     Write('Filename to use.=>');
  240.     Readln(filename);
  241.     if filename = '' then
  242.       begin
  243.       cleanup;
  244.       Exit
  245.       end;
  246.     filename:=FExpand(filename);
  247.     Assign(outfile, filename);
  248.     {$I-} Reset(outfile); {$I+}
  249.     if IOResult = 0 then
  250.       begin
  251.       Write(filename, ' exists! <O>verwrite, <A>ppend, <Q>uit.=>');
  252.       c:=getkey([ESC, 'O', 'A', 'Q']);
  253.       case c of
  254.         ESC, 'Q': begin
  255.                   Close(outfile);
  256.                   cleanup;
  257.                   Exit
  258.                   end;
  259.         'A': begin
  260.              Close(outfile);
  261.              Append(outfile)
  262.              end;
  263.         'O': begin
  264.              Close(outfile);
  265.              ReWrite(outfile)
  266.              end
  267.       end
  268.       end
  269.     else
  270.       ReWrite(outfile);
  271.     end;
  272.   Write('<N>ormal ASCII or <I>BM ASCII.=>');
  273.   c:=getkey([ESC, 'N', 'I']);
  274.   if c = ESC then
  275.     begin
  276.     cleanup;
  277.     Exit
  278.     end;
  279.   if c = 'N' then
  280.     striphi:=true
  281.   else
  282.     striphi:=false;
  283.   Write('Do you wish to add an extra header line? <Y> or <N>.=>');
  284.   c:=getkey([ESC, 'Y', 'N']);
  285.   if c = ESC then
  286.     begin
  287.     cleanup;
  288.     Exit
  289.     end;
  290.   extrastr:='';
  291.   if c = 'Y' then
  292.     begin
  293.     Write('Header>');
  294.     Readln(extrastr);
  295.     end;
  296.   bpl:=vidwid * 2;
  297.   bps:=bpl * vidlen;
  298.   {0 is top, print from line 2 to vidlen-2}
  299.   charcount:=0;
  300.   first:=bpl * 2;
  301.   last:=bps - (bpl * 2) - 1;
  302.   Writeln(outfile, dashes);
  303.   if Length(extrastr) > 0 then
  304.     Writeln(outfile, extrastr);
  305.   Writeln(outfile, 'Infoplus ', vernum, '   Page ', pg, ' - ', pgname);
  306.   Writeln(outfile, 'Generated: ', today, ' at ', time);
  307.   Writeln(outfile, dashes);
  308.   x:=first;
  309.   repeat
  310.     c:=scrbuf[x];
  311.     if Ord(c) < 31 then
  312.       c:=lochars[c];
  313.     if striphi and (Ord(c) > 127) then
  314.       c:=hichars[c];
  315.     Write(outfile, c);
  316.     Inc(charcount);
  317.     if charcount = 80 then
  318.       begin
  319.       Writeln(outfile);
  320.       charcount:=0;
  321.       end;
  322.     Inc(x, 2);
  323.   until x >= last;
  324.   Writeln(outfile);
  325.   Close(outfile);
  326.   cleanup
  327.   end;
  328. end.